home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Language/OS - Multiplatform Resource Library
/
LANGUAGE OS.iso
/
lisp
/
eulisp
/
you-075a.lha
/
you-075a
/
bytecodes.h
< prev
next >
Wrap
Text File
|
1992-09-14
|
12KB
|
574 lines
/* Contains definitions of all the bytecodes I'll use */
#define BC_NOP_CODE \
/* easy */
/* Arg 0: Module, Arg 1: offset */
#define BC_PUSH_GLOBAL_CODE \
{ \
int i,j; \
LispObject tmp; \
\
read_int_arg(i,pc); \
read_int_arg(j,pc); \
PUSH_VAL(sp,GLOB_REF(i,j)); \
}
#define BC_PUSH_STATIC_CODE \
{ \
int j; \
LispObject tmp; \
read_int_arg(j,pc); \
PUSH_VAL(sp,GLOB_REF(this_vector,j)); \
VCHECK(PEEK_VAL(sp)); \
}
#define BC_SET_STATIC_CODE \
{ \
int j; \
/**/ \
read_int_arg(j,pc); \
GLOB_REF(this_vector,j)=TOP_VAL(sp); \
}
/* Arg 0: module, Arg 1: offset */
#define BC_SET_GLOBAL_CODE \
{ \
int i,j; \
\
read_int_arg(i,pc); \
read_int_arg(j,pc); \
GLOB_REF(i,j) = TOP_VAL(sp); \
}
#define BC_PUSH_FIXNUM_CODE \
{ \
int i; \
LispObject tmp; \
read_int_arg(i,pc); \
tmp=allocate_integer(sp+1,i); \
PUSH_VAL(sp,tmp); \
}
#define BC_PUSH_SPECIAL_CODE \
{ \
switch (*(pc++)) \
{ \
case 0: \
PUSH_VAL(sp,BCnil); \
break; \
\
case 1: \
PUSH_VAL(sp,BCtrue); \
break; \
\
default: \
fprintf(stderr,"odd special"); \
PUSH_VAL(sp,BCnil); \
break; \
} \
}
/* args: n */
#define BC_PUSH_NTH_CODE \
{ \
int i; \
LispObject tmp; \
read_byte_arg(i,pc); \
/**/ \
tmp=NTH_REF(sp,i); \
PUSH_VAL(sp,tmp); \
}
/* Arg 1: n */
#define BC_SET_NTH_CODE \
{ \
int i; \
\
read_byte_arg(i,pc); \
\
NTH_REF(sp,i)=PEEK_VAL(sp); \
POP_VALS(sp,1); \
VCHECK(PEEK_VAL(sp)); \
}
/* Arg1: dist arg2: keep */
#define BC_SLIDE_STACK_CODE \
{ \
int depth,keep,n,counter; \
\
read_byte_arg(depth,pc); \
read_byte_arg(keep,pc); \
sp-= depth; \
n=depth-keep; \
for (counter=0; counter<keep; \
counter++) \
{ \
sp++; \
*sp= *(sp+n); \
} \
}
#define BC_SWAP_CODE \
{ \
LispObject tmp; \
\
tmp= *sp; \
*sp = *(sp-1); \
*(sp-1) = tmp; \
}
#define BC_DROP_CODE \
{ \
int i; \
\
read_byte_arg(i,pc) \
POP_VALS(sp,i); \
}
/* arg1: depth arg2: dist */
#define BC_ENV_REF_CODE \
{ \
int i,j,counter; \
LispObject env=PEEK_VAL(sp); \
\
read_byte_arg(i,pc); \
read_byte_arg(j,pc); \
ENV_REF(env,env,i,j); \
SHOVE_VAL(sp,env); \
VCHECK(PEEK_VAL(sp)); \
}
/* arg1: depth arg2: dist */
#define BC_SET_ENV_CODE \
{ \
int i,j,counter; \
LispObject env; \
LispObject val; \
val=TOP_VAL(sp); \
env=PEEK_VAL(sp); \
\
read_byte_arg(i,pc); \
read_byte_arg(j,pc); \
SET_ENV_REF(env,i,j,val); \
}
/* Arg1: Depth */
#define BC_POP_ENV_CODE \
{ \
int i,counter; \
LispObject env=PEEK_VAL(sp); \
\
read_byte_arg(i,pc); \
ENV_NTH(env,i); \
SHOVE_VAL(sp,env); \
VCHECK(PEEK_VAL(sp)); \
}
#define BC_MAKE_ENV_CODE \
{ \
int i; \
\
read_byte_arg(i,pc); \
MAKE_ENV(sp,i); \
VCHECK(PEEK_VAL(sp)); \
GC_RESTORE_GLOBALS; \
}
/* Object reference */
/* arg: n */
#define BC_VREF_CODE \
{ \
LispObject tmp=TOP_VAL(sp); \
/**/ \
SHOVE_VAL(sp,vref(PEEK_VAL(sp), \
intval(tmp))); \
VCHECK(PEEK_VAL(sp)); \
}
#if 0
if (intval(tmp) > PEEK_VAL(sp)->VECTOR.length)
CallError(sp+2,"duff vector-ref",PEEK_VAL(sp),NONCONTINUABLE);
#endif
/* arg: n */
#define BC_SET_VREF_CODE \
{ \
LispObject val=TOP_VAL(sp); \
LispObject loc; \
loc=TOP_VAL(sp); \
/**/ \
vref(PEEK_VAL(sp),intval(loc))=val; \
SHOVE_VAL(sp,val); \
}
#define BC_SLOT_REF_CODE \
{ \
LispObject obj=PEEK_VAL(sp); \
int i; \
/**/ \
read_byte_arg(i,pc); \
SHOVE_VAL(sp,slotref(obj,i)); \
VCHECK(PEEK_VAL(sp)); \
}
#define BC_SET_SLOT_CODE \
{ \
LispObject val; \
LispObject obj; \
int i; \
/**/ \
val=TOP_VAL(sp); \
obj=PEEK_VAL(sp); \
/**/ \
read_byte_arg(i,pc); \
slotref(obj,i)=val; \
SHOVE_VAL(sp,val); \
}
#define BC_SET_TYPE_CODE \
{ \
LispObject type; \
type=TOP_VAL(sp); \
/**/ \
lval_typeof(PEEK_VAL(sp))=intval(type); \
}
#define BC_BRANCH_CODE \
{ \
int i; \
bytecode *opc=pc; \
\
read_int_arg(i,pc); \
pc=ADJUST_PC(opc,i); \
}
#define BC_BRANCH_NIL_CODE \
{ \
int i; \
\
if (TOP_VAL(sp)==BCnil) \
{ \
bytecode *opc=pc; \
read_int_arg(i,pc); \
pc=ADJUST_PC(opc,i); \
} \
else \
skip_int_arg(pc); \
}
/* The tricky ones.... */
/* stack is: fn <lab> a0 a1....an fn */
/* return is: val */
#define GENERIC_LOOKUP \
#define BC_APPLY_ANY_CODE \
{ \
int nargs,abs_args,real_args; \
LispObject fn; \
LispObject *arg_start; \
/**/ \
read_sign_arg(nargs,pc); \
abs_args=nargs<0? -nargs: nargs; \
fn=TOP_VAL(sp); \
/**/ \
switch(typeof(fn)) \
{ \
case TYPE_GENERIC: \
{ \
LispObject ptr,*walker,fast; \
LispObject meths; \
LispObject *arg_1; \
int count; \
\
arg_1=(sp-nargs)+1; \
fast=(generic_fast_method_cache(fn)); \
ptr=CAR(fast); \
/* is there a cache ? */ \
if (ptr!=nil) \
{ \
/** Method lookup **/ \
walker=arg_1; \
count=0; \
while (count<nargs && CAR(ptr)==classof(*(walker))) \
{ \
ptr=CDR(ptr); \
walker++; count++; \
} \
\
if (count==nargs) \
{ \
meths=CDR(fast); \
goto call_method; \
} \
/* then the slow cache */ \
ptr=generic_slow_method_cache(fn); \
walker=arg_1; \
count=0; \
\
while(ptr!=nil && count<nargs) \
{ \
if (CAR(CAR(ptr))==classof(*(walker))) \
{ /* move down 1 */ \
ptr=CDR(CAR(ptr)); \
walker++; \
count++; \
} \
else \
ptr=CDR(ptr); \
} \
\
if (count==nargs) \
{ \
generic_fast_method_cache(fn)=ptr; \
meths=CDR(ptr); \
goto call_method; \
} \
/* not in slow cache */ \
} \
/* no cache */ \
{ \
LispObject res,args; \
LispObject *stacktop=sp+1,*stackbase=arg_1; \
STACK_TMP(fn); \
args=allocate_n_conses(stacktop,nargs); \
ptr=args; \
walker=stackbase; \
count=0; \
while (count<nargs) \
{ \
CAR(ptr)= *walker; \
ptr=CDR(ptr); ++walker; ++count; \
} \
UNSTACK_TMP(fn); \
/* Call the methods...*/ \
SET_STACK(sp,arg_1); \
*sp=fn; *(sp+1)=args; sp++; \
APPLY_BVF(GLOBAL_REF(Generic_Lookup_Fn),2); \
break; /* Wonder where to */ \
} \
call_method: \
/* method calling code */ \
BCM_CALL_METHOD_LIST(arg_1,meths,nargs); \
} \
break; \
case TYPE_B_FUNCTION: \
case TYPE_B_MACRO: \
{ \
int real_args=intval(bytefunction_nargs(fn)); \
if (nargs>=0 && real_args<0) \
{ \
int j=nargs+1; \
int k= -real_args; \
LispObject *cons_sp; \
*(++sp)=BCnil; \
cons_sp=sp+2; \
/*loop til we have lost enough*/ \
while (k!=j) \
{ \
LispObject tmp; \
*(sp+1)=fn; \
sp--; \
*cons_sp=*sp; \
*(cons_sp+1)=*(sp+1); \
tmp=Fn_cons(cons_sp); \
*sp=tmp; \
cons_sp--; \
fn=*(sp+2); \
j--; \
} \
GC_RESTORE_GLOBALS; \
} \
APPLY_BVF(fn,nargs); \
} \
break; \
default: \
{ \
LispObject res; \
arg_start=sp-abs_args; \
res=module_apply_args(arg_start+1,nargs,fn); \
GC_RESTORE_GLOBALS; \
POP_VALS(sp,abs_args); \
pc=SET_PC(this_vector,PEEK_VAL(sp)); \
POP_VALS(sp,1); \
*sp=res; \
} \
break; \
} \
}
#define BC_APPLY_BVF_CODE \
{ \
LispObject fn; \
int nargs; \
read_byte_arg(nargs,pc); \
/**/ \
fn=TOP_VAL(sp); \
APPLY_BVF(fn,nargs); \
}
#define BC_APPLY_METHODS_CODE \
{ \
LispObject ml; \
int args; \
LispObject *base; \
\
read_byte_arg(args,pc); \
base=sp-args; \
\
ml=TOP_VAL(sp); \
\
BCM_CALL_METHOD_LIST(base,ml,args); \
}
#define BC_PUSH_LABEL_CODE \
{ /* istream should hold an offset */ \
bytecode *new_pc; \
LispObject xx; \
int i; \
bytecode *opc=pc; \
/**/ \
read_int_arg(i,pc); \
new_pc=ADJUST_PC(opc,i); \
BC_BUG( if (GLOBAL_REF(BC_Debug)==BCtrue) fprintf(stderr,"Push lab: %x",new_pc)); \
xx=REIFY_PC(new_pc); \
PUSH_VAL(sp,xx); \
}
/* stack is: fn <addr> retval */
#define BC_RETURN_CODE /* and back */ \
{ \
LispObject tmp=TOP_VAL(sp); \
/**/ \
VCHECK(tmp); \
pc=SET_PC(this_vector,PEEK_VAL(sp)); \
POP_VALS(sp,1); \
SHOVE_VAL(sp,tmp); \
}
/** External environment */
#define BC_CONTEXT_CODE \
{ \
LispObject tmp; \
tmp=allocate_integer(sp+1,this_vector); \
PUSH_VAL(sp,tmp); \
} \
#define BC_EXIT_CODE \
{ \
BC_BUG( if (GLOBAL_REF(BC_Debug)==BCtrue) fprintf(stderr,"{exiting: %x}",sp)); \
return (TOP_VAL(sp)); \
}
/* allocation */
#define BC_CONS_CODE \
{ \
LispObject tmp; \
/**/ \
tmp=Fn_cons(sp-1); \
POP_VALS(sp,1); \
SHOVE_VAL(sp,tmp); \
GC_RESTORE_GLOBALS; \
}
#define BC_NULLP_CODE \
{ \
if (PEEK_VAL(sp)==BCnil)\
SHOVE_VAL(sp,BCtrue); \
else \
SHOVE_VAL(sp,BCnil); \
}
#define BC_EQP_CODE \
{ \
LispObject tmp; \
/**/ \
tmp=TOP_VAL(sp); \
/**/ \
if (PEEK_VAL(sp)==tmp) \
SHOVE_VAL(sp,BCtrue); \
else \
SHOVE_VAL(sp,BCnil); \
}
#define BC_ALLOC_CLOSURE_CODE \
{ /* expect <label> <env> on stack, nargs in stream */ \
LispObject env; \
LispObject rpc; \
LispObject tmp,tmp2; \
bytecode *start; \
int vector; \
int nargs; \
/* ought to be a long */ \
read_sign_arg(nargs,pc); \
\
tmp=allocate_instance(sp+1,ByteFunction); \
lval_typeof(tmp)=TYPE_B_FUNCTION; \
bytefunction_env(tmp)=TOP_VAL(sp); \
\
/* Tacky... grab the (reified) label and extract into closure */ \
rpc=TOP_VAL(sp); \
start=SET_PC(vector,rpc); \
PUSH_VAL(sp,tmp); \
tmp2=allocate_integer(sp+1,vector); \
tmp=PEEK_VAL(sp); \
bytefunction_codenum(tmp)=tmp2; \
tmp=allocate_integer(sp+1,nargs); \
bytefunction_nargs(PEEK_VAL(sp))=tmp; \
tmp=allocate_integer(sp+1,start-bytevector_start(vector)); \
bytefunction_offset(PEEK_VAL(sp))=tmp; \
GC_RESTORE_GLOBALS; \
}
/* Inserted by other macros */
/* bungs return onto stack */
#define BCM_CALL_METHOD_LIST(base,ml,nargs) \
{ \
LispObject mf; \
\
mf=method_function(CAR(ml)); \
switch(typeof(mf)) \
{ \
case TYPE_B_FUNCTION: \
/* stuff meths somewhere */ \
SET_NTH_REF(base,2,ml); \
APPLY_BVF(mf,nargs); \
break; \
\
default: \
{ \
LispObject res; \
res = call_method(base,nargs,ml); \
GC_RESTORE_GLOBALS; \
SET_STACK(sp,base-1); \
pc=SET_PC(this_vector,PEEK_VAL(sp)); \
POP_VALS(sp,1); \
SHOVE_VAL(sp,res); \
break; \
} \
} \
}
#define APPLY_BVF(fn,nargs) \
{ \
/* Set the return address */ \
/*SET_NTH_REF(sp,nargs+1, \
REIFY_PC(pc));*/ \
pc=BF2PC(fn); \
/* Push environment */ \
PUSH_VAL(sp,bytefunction_env(fn)); \
}